CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/swagn_r.zip/NUMBERS.SWG/0062_Huge Numbers!.pas

Pascal/Delphi Source File | 1995-03-03 | 4KB | 226 lines

unit HugeUtil;

interface

const HugeMax = $8000-16;

type  Huge = record
              len : word;
              dat : array[1..HugeMax] of word;
            end;
      HugePtr = ^Huge;

procedure AddHuge  (var Answer, Add : Huge);
procedure MulHuge  (var A : Huge; Mul : integer; var Answer : Huge);
procedure DivHuge  (var A : Huge; Del : integer; var Answer : Huge;
                    var Remainder : integer);
procedure SubHuge  (var Answer, Sub : Huge);
procedure ZeroHuge (var L : Huge; Size : word);
procedure CopyHuge (var Fra,Til : Huge);
procedure GetHuge  (var P : HugePtr; Size : word);
procedure WriteHuge(var L : Huge; Size: word);

implementation

procedure AddHuge; assembler; asm
  cld
  push  ds
  lds   di,Answer
  les   si,Add
  seges lodsw
  mov   cx,ax
  clc
@l1:
  seges lodsw
  adc   [si-2],ax
  loop  @l1
  jnb   @done
@l2:
  add   word [si],1
  inc   si
  inc   si
  jc    @l2
@done:
  mov   si,di
  lodsw
  shl   ax,1
  add   si,ax
  lodsw
  or    ax,ax
  je    @d2
  inc   word [di]
@d2:
  pop   ds
end;

procedure MulHuge; assembler; asm
  cld
  push  ds
  lds   si,A
  mov   bx,Mul
  les   di,Answer
  mov   cx,[si]
  mov   dx,si
  inc   di
  inc   di
  clc
@l1:
  mov   ax,[di]
  pushf
  mul   bx
  popf
  adc   ax,si
  stosw
  mov   si,dx
  loop  @l1
  adc   si,0
  mov   es:[di],si
  lds   di,A
  mov   di,[di]
  mov   ax,[di+2]
  or    ax,ax
  je    @l2
  inc   di
  inc   di
@l2:
  lds   si,Answer
  mov   [si],di
  pop   ds
end;

procedure DivHuge; assembler; asm
  std
  push  ds
  lds   si,A
  mov   bx,Del
  les   di,Answer
  mov   cx,[si]
  mov   di,cx
  add   di,cx
  xor   dx,dx
@l1:
  mov   ax,[di]
  div   bx
  stosw
  loop  @l1
  lds   si,Remainder
  mov   [si],dx
  lds   si,A
  mov   ax,[si]
  lds   di,Answer
  mov   [di],ax
  mov   si,[di]
  shl   si,1
@d3:
  lodsw
  or    ax,ax
  jne   @d2
  dec   word [di]
  jne   @d3
  inc   word [di]
@d2:
  pop   ds
end;

procedure SubHuge; assembler; asm
  cld
  push  ds
  lds   di,Answer
  les   si,Sub
  seges lodsw
  mov   cx,ax
  clc
@l1:
  seges lodsw
  sbb   [si-2],ax
  loop  @l1
  jnb   @done
@l2:
  sub   word [si],1
  inc   si
  inc   si
  jc    @l2
@done:
  mov   si,[di]
  shl   si,1
  std
@d3:
  lodsw
  or    ax,ax
  jne   @d2
  dec   word [di]
  jne   @d3
  inc   word [di]
@d2:
  pop   ds
end;


procedure WriteHuge;
var L1, L2, I, R, R1, X : integer;
begin
  with L do begin
    L1 := Len;
    L2 := L1 - 1;
    I := 1;
    write(dat[L1],'.');
    X := 0;
    for I := 1 to Size div 4 do begin
      Dat[L1] := 0;
      Len := L2;
      MulHuge(L,10000,L);
      R := dat[L1];
      R1 := R div 100;
      R  := R mod 100;
      write(chr(R1 div 10+48), chr(R1 mod 10+48),
            chr(R  div 10+48), chr(R  mod 10+48));
      inc(X);
      write(' ');
      if X > 14 then begin
        writeln; write('  ');
        X := 0
      end
    end
  end;
  writeln
end;                            { WriteHuge }

procedure ZeroHuge;
begin
  fillchar(L.Dat, Size * 2, #0);
  L.Len := Size
end;

procedure CopyHuge;
begin
  move(Fra, Til, Fra.Len * 2 + 2)
end;

procedure GetHuge;
var D : ^byte;
    Tries,
    Bytes : word;
begin
  Bytes := 2 * (Size + 1);
  Tries:=0;
  repeat
    getmem(P,Bytes);

{ To make it possible to use maximally large arrays, and to increase
  the speed of the computations, all records of type Huge MUST start
  at a segment boundary! }

    if ofs(P^) = 0 then begin
      ZeroHuge(P^,Size);
      exit
    end;
    inc(Tries);
    freemem(P,Bytes);
    new(D)
  until Tries>10;   { if not done yet, it's not likely we ever will be }
  writeln('Couldn''t get memory for array');
  halt(1)
end;                                   { GetHuge }

end.